PC go! 2008 April/PCgo 2008-04 (DVD).iso/interface/contents/demoversionen_3846/13664/files/Data1.cab/inet.cls

Visual Basic class definition | 2004-05-21 | 9.2 KB | 264 lines

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "Inet"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
'/******************************************************************/
'/*                                                                */
'/*                      TurboCAD for Windows                      */
'/*                   Copyright (c) 1993 - 2001                    */
'/*             International Microcomputer Software, Inc.         */
'/*                            (IMSI)                              */
'/*                      All rights reserved.                      */
'/*                                                                */
'/******************************************************************/
' it is an example of simply tool that run I browser with predefined URL
' In order to use it select a graphic with URL property defined and then run Hyperlink tool

Option Explicit

'Number of tools in this dll
Const NUM_TOOLS = 1
'Toggle this to test loading buttons from .Bmp/.Res
Const boolLoadFromBmp As Boolean = False
Const boolDebug As Boolean = False

'Return a description string for this package of tools
Public Property Get Description() As String
    Description = "Internet connection tool"
End Property

'Called to perform tool function
Public Function Run(ByVal Tool As Object) As Boolean
    Dim objApp As Object
    Dim objSel As Object
    Dim objGraphic As Object
    Dim strURL As String
    On Error Resume Next

    'Look for first URL property in the selection
    Set objApp = Tool.Application
    Set objSel = objApp.Selection
    For Each objGraphic In objSel
' look for first graphic with URL defined
        strURL = ""
        strURL = objGraphic.Properties("URL")
        If strURL <> "" Then
            StartBrowser strURL
            Run = True
            Exit Function
        End If
    Next objGraphic

    'No selection or no URLs: just start browser at a convenient home page
    ' no one graphic from selected have property URL filled so start the browser with default url
    StartBrowser "http://www.imsisoft.com/"
    Run = True
End Function

'Fill arrays with information about tools in the package
'Return the number of tools in the package
Public Function GetToolInfo(CommandNames As Variant, MenuCaptions As Variant, StatusPrompts As Variant, _
    ToolTips As Variant, Enabled As Variant, WantsUpdates As Variant) As Long
    ReDim CommandNames(NUM_TOOLS)
    ReDim MenuCaptions(NUM_TOOLS, 2)
    ReDim StatusPrompts(NUM_TOOLS)
    ReDim ToolTips(NUM_TOOLS)
    ReDim Enabled(NUM_TOOLS)
    ReDim WantsUpdates(NUM_TOOLS)
'    CommandNames(0) = "SDK|Hyperlink" ' Menu + Command Name
    CommandNames(0) = "&AddOns|S&DK Samples|&Tools|Hyperlink" + "#CMD_SDKHYPERLINK" ' Menu + Command Name
    MenuCaptions(0, 0) = "&Hyperlink"
    MenuCaptions(0, 1) = "SDK Samples" ' toolbar name
    StatusPrompts(0) = "Launch a browser on the World Wide Web"
    ToolTips(0) = "Hyperlink"
    Enabled(0) = True
    WantsUpdates(0) = False
    GetToolInfo = NUM_TOOLS
End Function


'Copy a windows bitmap of the requested size to the clipboard
'Bitmaps returned should contain NUM_TOOLS images
'Size of entire bitmap:
'Normal:  (NUM_TOOLS*16) wide x 15 high
'Large:   (NUM_TOOLS*24) wide x 23 high
'Mono bitmap should be 1-bit (black or white)
Public Function CopyBitmap(ByVal LargeImage As Boolean, ByVal MonoImage As Boolean) As Boolean
    On Error GoTo BitmapError

    Dim TheImage As New StdPicture
    If GetButtonPicture(LargeImage, MonoImage, TheImage) Then
        'Put the image on the Windows clipboard
        Clipboard.SetData TheImage, vbCFDIB
        CopyBitmap = True
        Exit Function
    End If

BitmapError:
    CopyBitmap = False
End Function

'Return a Picture object for the requested size
'Apparently, returning references to StdPicture objects doesn't work for .EXE servers
'Bitmaps returned should contain NUM_TOOLS images
'Size of entire image:
'Normal:  (NUM_TOOLS*16) wide x 15 high
'Large:   (NUM_TOOLS*24) wide x 23 high
'Mono image should be 1-bit (black or white)
Public Function GetPicture(ByVal LargeImage As Boolean, ByVal MonoImage As Boolean) As Object
    On Error GoTo PictureError

    Dim TheImage As New StdPicture
    If GetButtonPicture(LargeImage, MonoImage, TheImage) Then
        Set GetPicture = TheImage
        Exit Function
    End If

PictureError:
    Set GetPicture = Nothing
End Function

'Returns true if tool is correctly initialized
Public Function Initialize(ByVal Tool As Object) As Boolean
    Initialize = True
End Function

'Returns true if tool is correctly initialized
Public Function UpdateToolStatus(ByVal Tool As Object, Enabled As Boolean, Checked As Boolean) As Boolean
    Enabled = True 'Could do a test here to determine whether to disable the button/menu item
    Checked = False  'Could do a test here to determine whether to check the button/menu item
    UpdateToolStatus = True
End Function

'Implementation specific stuff
'Private function to return the bitmap from .Res file or .Bmp file
Private Function GetButtonPicture(ByVal LargeImage As Boolean, ByVal MonoImage As Boolean, TheImage As StdPicture) As Boolean
    On Error GoTo LoadError

    'There are two ways to load images:  from .Bmp file(s) or from .RES resource.
    'In this demo, we control the loading by a private variable.

    'Note that if you are loading from .Bmp, or if you are running this tool as a
    '.VBP for debugging, you must place the .Res or .Bmp files in the Draggers subdirectory
    'of the directory in which TCW80.EXE (or IMSIGX90.dll) is located.

    If boolLoadFromBmp Then
        'Load from .Bmp file
        Dim strFileName As String 'File name of .Bmp file to load

        If LargeImage Then
            strFileName = App.Path & "\button24.bmp"
        Else
            strFileName = App.Path & "\button16.bmp"
        End If
        Set TheImage = LoadPicture(strFileName)
    Else
        'Load from .Res file
        Dim idBitmap%  'BITMAP resource id in .Res file

        If LargeImage Then
            idBitmap% = 102
        Else
            idBitmap% = 101
        End If
        Set TheImage = LoadResPicture(idBitmap%, vbResBitmap)
    End If

    'Return the image
    GetButtonPicture = True
    Exit Function

LoadError:
    If boolDebug Then
        MsgBox "Error loading bitmap: " & Err.Description
    End If
    GetButtonPicture = False
End Function

'We get the name of the installed internet browser from the Windows registry
Private Function QueryValueEx(ByVal lhKey As Long, ByVal szValueName As String, vValue As Variant) As Long
    Dim cch As Long
    Dim lrc As Long
    Dim lType As Long
    Dim lValue As Long
    Dim sValue As String

    On Error GoTo QueryValueExError

    ' Determine the size and type of data to be read
    lrc = RegQueryValueExNULL(lhKey, szValueName, 0&, lType, 0&, cch)
    If lrc <> ERROR_NONE Then Error 5

    Select Case lType
        ' For strings
        Case REG_SZ:
            sValue = String(cch, 0)

            lrc = RegQueryValueExString(lhKey, szValueName, 0&, lType, sValue, cch)
            If lrc = ERROR_NONE Then
                If cch > 0 Then
                    cch = cch - 1
                End If
                vValue = Left$(sValue, cch)
            Else
                vValue = Empty
            End If
        ' For DWORDS
        Case REG_DWORD:
            lrc = RegQueryValueExLong(lhKey, szValueName, 0&, lType, lValue, cch)
            If lrc = ERROR_NONE Then vValue = lValue
        Case Else
            'all other data types not supported
            lrc = -1
    End Select

QueryValueExExit:
    QueryValueEx = lrc
    Exit Function

QueryValueExError:
    Resume QueryValueExExit

End Function

'Get a string value from the registry
Private Function QueryValueString(ByVal lRootKey As Long, ByVal sKeyName As String, ByVal sValueName As String) As String
    Dim lRetVal As Long         'result of the API functions
    Dim hKey As Long         'handle of opened key
    Dim vValue As Variant      'setting of queried value

    lRetVal = RegOpenKeyEx(lRootKey, sKeyName, 0, KEY_ALL_ACCESS, hKey)
    lRetVal = QueryValueEx(hKey, sValueName, vValue)
    QueryValueString = vValue
    RegCloseKey (hKey)
End Function

'Private function to startup the registered internet browser at a specified URL
Private Function StartBrowser(strURL As String)
    Dim HRes As Long
    Dim TheKey As Long
    Dim strExec As String

    'Get the browser command from the registry
    strExec = QueryValueString(HKEY_LOCAL_MACHINE, "SOFTWARE\Classes\HTTP\shell\open\command", "")
    If strExec <> "" Then
        If strURL <> "" Then

            'Embed the URL in quotes and build a command line
            strExec = strExec & " " & Chr$(34) & strURL & Chr$(34)
        End If

        'Invoke the browser
        WinExec strExec, SW_SHOW
    End If
End Function